home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 001-025 / disk_003 / cforth / prims.c < prev    next >
C/C++ Source or Header  |  1992-05-06  |  11KB  |  486 lines
  1. /*
  2.  * prims.c -- code for the primitive functions declared in forth.dict
  3.  */
  4.  
  5. #include <stdio.h>
  6. #include <ctype.h>    /* used in "digit" */
  7. #include "common.h"
  8. #include "forth.h"
  9. #include "prims.h"    /* macro primitives */
  10.  
  11. /*
  12.              ----------------------------------------------------
  13.                             PRIMITIVE DEFINITIONS
  14.              ----------------------------------------------------
  15. */
  16.  
  17. zbranch()            /* add an offset (branch) if tos == 0 */
  18. {
  19.     if(pop() == 0) 
  20.         ip += mem[ip];
  21.     else
  22.         ip++;        /* else skip over the offset */
  23. }
  24.  
  25. ploop()                /* (loop) -- loop control */
  26. {
  27.     short index, limit;
  28.     index = rpop()+1;
  29.     if(index < (limit = rpop())) {   /* if the new index < the limit */
  30.         rpush(limit);    /* restore the limit */
  31.         rpush(index);    /* and the index (incremented) */
  32.         branch();    /* and go back to the top of the loop */
  33.     }
  34.     else ip++;             /* skip over the offset, and exit, having
  35.                    popped the limit & index */
  36. }
  37.  
  38. pploop()            /* (+loop) -- almost the same */
  39. {
  40.     short index, limit;
  41.     index = rpop()+pop();        /* get index & add increment */
  42.     if(index < (limit = rpop())) {    /* if new index < limit */
  43.         rpush (limit);        /* restore the limit */
  44.         rpush (index);        /* restore the new index */
  45.         branch();        /* and branch back to the top */
  46.     }
  47.     else {
  48.         ip++;        /* skip over branch offset */
  49.     }
  50. }
  51.  
  52. pdo()            /* (do): limit init -- [pushed to rstack] */
  53. {
  54.     swap();
  55.     rpush (pop());
  56.     rpush (pop());
  57. }
  58.  
  59. i()            /* copy top of return stack to cstack */
  60. {
  61.     int tmp;
  62.     tmp = rpop();
  63.     rpush(tmp);
  64.     push(tmp);
  65. }
  66.  
  67. r()        /* this must be a primitive as well as I because otherwise it
  68.            always returns its own address */
  69. {
  70.     i();
  71. }
  72.  
  73. digit()            /* digit: c -- FALSE or [v TRUE] */
  74. {
  75.     short c, base;        /* C is ASCII char, convert to val. BASE is
  76.                    used for range checking */
  77.     base = pop();
  78.     c = pop();
  79.     if (!isascii(c)) {
  80.     push (FALSE);
  81.     return;
  82.     }
  83.                  /* lc -> UC if necessary */
  84.     if (islower(c)) c = toupper(c);
  85.  
  86.     if (c < '0' || (c > '9' && c < 'A') || c > 'Z') {
  87.     push(FALSE);        /* not a digit */
  88.     }
  89.     else {            /* it is numeric or UC Alpha */
  90.     if (c >= 'A') c -= 7;    /* put A-Z right after 0-9 */
  91.  
  92.     c -= '0';        /* now c is 0..35 */
  93.  
  94.     if (c >= base) {
  95.         push (FALSE);    /* FALSE - not a digit */
  96.     }
  97.     else {            /* OKAY: push value, then TRUE */
  98.         push (c);
  99.         push (TRUE);
  100.     }
  101.     }
  102. }
  103.  
  104. pfind()        /* WORD TOP -- xx FLAG, where TOP is NFA to start at;
  105.            WORD is the word to find; xx is PFA of found word;
  106.            yy is actual length of the word found;
  107.            FLAG is 1 if found. If not found, 0 alone is stacked. */
  108. {
  109.     unsigned short  worka, workb, workc, current, word, match;
  110.  
  111.     current = pop ();
  112.     word = pop ();
  113.     while (current) {        /* stop at end of dictionary */
  114.     if (!((mem[current] ^ mem[word]) & 0x3f)) {
  115.                 /* match lengths & smudge */
  116.         worka = current + 1;/* point to the first letter */
  117.         workb = word + 1;
  118.         workc = mem[word];    /* workc gets count */
  119.         match = TRUE;    /* initally true, for looping */
  120.         while (workc-- && match)
  121.         match = ((mem[worka++] & 0x7f) == (mem[workb++] & 0x7f));
  122.         if (match) {    /* exited with match TRUE -- FOUND IT */
  123.         push (worka + 2);        /* worka=LFA; push PFA */
  124.         push (mem[current]);        /* push length byte */
  125.         push (TRUE);            /* and TRUE flag */
  126.         return;
  127.         }
  128.     }
  129.     /* failed to match */
  130.     /* follow link field to next word */
  131.     current = mem[current + (mem[current] & 0x1f) + 1];
  132.     }
  133.     push (FALSE);        /* current = 0; end of dict; not found */
  134. }
  135.  
  136. enclose()
  137. {
  138.     int delim, current, offset;
  139.  
  140.     delim = pop();
  141.     current = pop();
  142.     push (current);
  143.  
  144.     offset = -1;
  145.     current--;
  146. encl1:
  147.     current++;
  148.     offset++;
  149.     if (mem[current] == delim) goto encl1;
  150.  
  151.     push(offset);
  152.     if (mem[current] == NULL) {
  153.         offset++;
  154.         push (offset);
  155.         offset--;
  156.         push (offset);
  157.         return;
  158.     }
  159.  
  160. encl2:
  161.     current++;
  162.     offset++;
  163.     if (mem[current] == delim) goto encl4;
  164.     if (mem[current] != NULL) goto encl2;
  165.  
  166.     /* mem[current] is null.. */
  167.     push (offset);
  168.     push (offset);
  169.     return;
  170.  
  171. encl4:    /* found the trailing delimiter */
  172.     push (offset);
  173.     offset++;
  174.     push (offset);
  175.     return;
  176. }
  177.  
  178. cmove()            /* cmove: source dest number -- */
  179. {
  180.     short source, dest, number, i;
  181.     number = pop();
  182.     dest = pop();
  183.     source = pop();
  184.     for ( ; number ; number-- ) mem[dest++] = mem[source++];
  185. }
  186.  
  187. fill()            /* fill: c dest number -- */
  188. {
  189.     short dest, number, c;
  190.     number = pop();
  191.     dest = pop();
  192.     c = pop();
  193.  
  194.     mem[dest] = c;        /* always at least one */
  195.     if (number == 1) return;    /* return if only one */
  196.  
  197.     push (dest);        /* else push dest as source of cmove */
  198.     push (dest + 1);        /* dest+1 as dest of cmove */
  199.     push (number - 1);        /* number-1 as number of cmove */
  200.     cmove();
  201. }
  202.  
  203. ustar()                /* u*: a b -- a*b.hi a*b.lo */
  204. {
  205.     unsigned short a, b;
  206.     unsigned long c;
  207.     a = (unsigned short)pop();
  208.     b = (unsigned short)pop();
  209.     c = a * b;
  210.  
  211.     /* (short) -1 is probably FFFF, which is just what we want */
  212.     push ((unsigned short)(c & (short) -1));          /* low word of product */
  213.                              /* high word of product */
  214.     push ((short)((c >> (8*sizeof(short))) & (short) -1));
  215. }
  216.  
  217. uslash()            /* u/: NUM.LO NUM.HI DENOM -- REM QUOT */
  218. {
  219.     unsigned short numhi, numlo, denom;
  220.     unsigned short quot, remainder;    /* the longs below are to be sure the
  221.                        intermediate computation is done
  222.                        long; the results are short */
  223.     denom = pop();
  224.     numhi = pop();
  225.     numlo = pop();
  226.     quot = ((((unsigned long)numhi) << (8*sizeof(short))) 
  227.                 + (unsigned long)numlo) 
  228.                     / (unsigned long)denom;
  229.  
  230.     remainder = ((((unsigned long)numhi) << (8*sizeof(short))) 
  231.                 + (unsigned long)numlo) 
  232.                     % (unsigned long)denom;
  233.  
  234.     push (remainder);
  235.     push (quot);
  236. }
  237.  
  238. swap()                /* swap: a b -- b a */
  239. {
  240.     short a, b;
  241.     b = pop();
  242.     a = pop();
  243.     push (b);
  244.     push (a);
  245. }
  246.  
  247. rot()                /* rotate */
  248. {
  249.     short a, b, c;
  250.     a = pop ();
  251.     b = pop ();
  252.     c = pop ();
  253.     push (b);
  254.     push (a);
  255.     push (c);
  256. }
  257.  
  258. tfetch()            /* 2@: addr -- mem[addr+1] mem[addr] */
  259. {
  260.     unsigned short addr;
  261.     addr = pop();
  262.     push (mem[addr + 1]);
  263.     push (mem[addr]);
  264. }
  265.  
  266. store()            /* !: val addr -- <set mem[addr] = val> */
  267. {
  268.     unsigned short tmp;
  269.     tmp = pop();
  270.     mem[tmp] = pop();
  271. }
  272.  
  273. cstore()            /* C!: val addr --  */
  274. {
  275.     store();
  276. }
  277.  
  278. tstore()            /* 2!: val1 val2 addr -- 
  279.                    mem[addr] = val2,
  280.                    mem[addr+1] = val1 */
  281. {
  282.     unsigned short tmp;
  283.     tmp = pop();
  284.     mem[tmp] = pop();
  285.     mem[tmp+1] = pop();
  286. }
  287.  
  288. leave()            /* set the index = the limit of a DO */
  289. {
  290.     int tmp;
  291.     rpop();            /* discard old index */
  292.     tmp = rpop();        /* and push the limit as */
  293.     rpush(tmp);            /* both the limit */
  294.     rpush(tmp);            /* and the index */
  295. }
  296.  
  297. dplus()                /* D+: double-add */
  298. {
  299.     short ahi, alo, bhi, blo;
  300.     long a, b;
  301.     bhi = pop();
  302.     blo = pop();
  303.     ahi = pop();
  304.     alo = pop();
  305.     a = ((long)ahi << (8*sizeof(short))) + (long)alo;
  306.     b = ((long)bhi << (8*sizeof(short))) + (long)blo;
  307.     a = a + b;
  308.     push ((unsigned short)(a & (short) -1));    /* sum lo */
  309.     push ((short)(a >> (8*sizeof(short))));    /* sum hi */
  310. }
  311.  
  312. subtract()            /* -: a b -- (a-b) */
  313. {
  314.     int tmp;
  315.     tmp = pop();
  316.     push (pop() - tmp);
  317. }
  318.  
  319. dsubtract()            /* D-: double-subtract */
  320. {
  321.     short ahi, alo, bhi, blo;
  322.     long a, b;
  323.     bhi = pop();
  324.     blo = pop();
  325.     ahi = pop();
  326.     alo = pop();
  327.     a = ((long)ahi << (8*sizeof(short))) + (long)alo;
  328.     b = ((long)bhi << (8*sizeof(short))) + (long)blo;
  329.     a = a - b;
  330.     push ((unsigned short)(a & (short) -1));    /* diff lo */
  331.     push ((short)(a >> (8*sizeof(short))));    /* diff hi */
  332. }
  333.  
  334. dminus()                /* DMINUS: negate a double number */
  335. {
  336.     unsigned short ahi, alo;
  337.     long a;
  338.     ahi = pop();
  339.     alo = pop();
  340.     a = -(((long)ahi << (8*sizeof(short))) + (long)alo);
  341.     push ((unsigned short)(a & (short) -1));        /* -a lo */
  342.     push ((unsigned short)(a >> (8*sizeof(short))));     /* -a hi */
  343. }
  344.  
  345. over()                /* over: a b -- a b a */
  346. {
  347.     short a, b;
  348.     b = pop();
  349.     a = pop();
  350.     push (a);
  351.     push (b);
  352.     push (a);
  353. }
  354.  
  355. dup()                /* dup: a -- a a */
  356. {
  357.     short a;
  358.     a = pop();
  359.     push (a);
  360.     push (a);
  361. }
  362.  
  363. tdup()            /* 2dup: a b -- a b a b */
  364. {
  365.     short a, b;
  366.     b = pop();
  367.     a = pop();
  368.     push (a);
  369.     push (b);
  370.     push (a);
  371.     push (b);
  372. }
  373.  
  374. pstore()            /* +!: val addr -- <add val to mem[addr]> */
  375. {
  376.     short addr, val;
  377.     addr = pop();
  378.     val = pop();
  379.     mem[addr] += val;
  380. }
  381.  
  382. toggle()            /* toggle: addr bits -- <xor mem[addr]
  383.                    with bits, store in mem[addr]> */
  384. {
  385.     short bits, addr;
  386.     bits = pop();
  387.     addr = pop();
  388.     mem[addr] ^= bits;
  389. }
  390.  
  391. less()
  392. {
  393.     int tmp;
  394.     tmp = pop();
  395.     push (pop() < tmp);
  396. }
  397.  
  398. pcold()
  399. {
  400.     csp = INITS0;        /* initialize values */
  401.     rsp = INITR0;
  402.     /* copy USER_DEFAULTS area into UP area */
  403.     push (USER_DEFAULTS);    /* source */
  404.     push (UP);            /* dest */
  405.     push (DEFS_SIZE);        /* count */
  406.     cmove();            /* move! */
  407.                 /* returns, executes ABORT */
  408. }
  409.  
  410. prslw()
  411. {
  412.     int buffer, flag, addr, i, temp;
  413.     int unwrittenflag = !TRUE;
  414.     long fpos, ftell();
  415.     char buf[1024];        /* holds data for xfer */
  416.  
  417.     flag = pop();
  418.     buffer = pop();
  419.     addr = pop();
  420.     fpos = (long) (buffer * 1024);
  421.  
  422.                     /* extend if necessary */
  423.     if (fpos >= bfilesize) {
  424.         if (flag == 0) {         /* write */
  425.         printf("Extending block file to %D bytes\n", fpos+1024);
  426.         /* the "2" below is the fseek magic number for "beyond end" */
  427.         fseek(blockfile, (fpos+1024) - bfilesize, 2);
  428.         bfilesize = ftell(blockfile);
  429.         }
  430.         else {            /* reading unwritten data */
  431.         unwrittenflag = TRUE;    /* will read all zeroes */
  432.         }
  433.     }
  434.     else {
  435.         /* note that "0" below is fseek magic number for "relative to
  436.            beginning-of-file" */
  437.         fseek(blockfile, fpos, 0);    /* seek to destination */
  438.     }
  439.  
  440.     if (flag) {        /* read */
  441.         if (unwrittenflag) {    /* not written yet */
  442.         for (i=0; i<1024; i++) mem[addr++] = 0;    /* "read" nulls */
  443.         }
  444.         else {            /* does exist */
  445.         if ((temp = fread (buf, sizeof(char), 1024, blockfile)) 
  446.                                 != 1024) {
  447.             fprintf (stderr,
  448.                 "File read error %d reading buffer %d\n",
  449.                     temp, buffer);
  450.             errexit();
  451.         }
  452.         for (i=0; i<1024; i++) mem[addr++] = buf[i];
  453.         }
  454.     }
  455.     else {    /* write */
  456.         for (i=0; i<1024; i++) buf[i] = mem[addr++];
  457.         if ((temp = fwrite (buf, sizeof(char), 1024, blockfile))
  458.                                  != 1024) {
  459.                 fprintf(stderr,
  460.                 "File write error %d writing buffer %d\n",
  461.                     temp, buffer);
  462.                 errexit();
  463.         }
  464.     }
  465. }
  466.  
  467. psave()
  468. {
  469.     FILE *fp;
  470.  
  471.     printf("\nSaving...");
  472.     fflush(stdout);
  473.     mem[SAVEDIP] = ip;    /* save state */
  474.     mem[SAVEDSP] = csp;
  475.     mem[SAVEDRP] = rsp;
  476.  
  477.     if ((fp = fopen(sfilename,"w")) == NULL)  /* open for writing only */
  478.         errexit("Can't open core file %s for writing\n", sfilename);
  479.     if (fwrite(mem, sizeof(*mem), mem[0], fp) != mem[0])
  480.         errexit("Write error on %s\n",sfilename);
  481.     if (fclose(fp) == EOF)
  482.         errexit("Close error on %s\n",sfilename);
  483.     puts("Saved. Exit FORTH.");
  484.     exit(0);
  485. }
  486.